home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / tls / tls074c.sunsparc.Z / tls074c.sunsparc / usr / lib / tcl / tcl.tlib < prev    next >
Encoding:
Text File  |  1995-07-20  |  34.3 KB  |  1,385 lines
  1.  
  2. #@package: TclX-ArrayProcedures for_array_keys
  3.  
  4. proc for_array_keys {varName arrayName codeFragment} {
  5.     upvar $varName enumVar $arrayName enumArray
  6.  
  7.     if ![info exists enumArray] {
  8.     error "\"$arrayName\" isn't an array"
  9.     }
  10.  
  11.     set searchId [array startsearch enumArray]
  12.     while {[array anymore enumArray $searchId]} {
  13.     set enumVar [array nextelement enumArray $searchId]
  14.     uplevel $codeFragment
  15.     }
  16.     array donesearch enumArray $searchId
  17. }
  18.  
  19. #@package: TclX-Compatibility execvp assign_fields
  20.  
  21. proc execvp {progname args} {
  22.     error "The execvp command is outdated, use the execl command directly"
  23. }
  24. proc assign_fields {list args} {
  25.     if [lempty $args] {
  26.         return
  27.     }
  28.     return [uplevel lassign [list $list] $args]
  29. }
  30.  
  31. #@package: TclX-convertlib convert_lib
  32.  
  33.  
  34. proc tclx:ParseTclIndex {tclIndex fileTblVar ignore} {
  35.     upvar $fileTblVar fileTbl
  36.     set allOK 1
  37.  
  38.  
  39.     set tclIndexFH [open $tclIndex r]
  40.     set hdr [gets $tclIndexFH]
  41.     if {$hdr != "# Tcl autoload index file, version 2.0"} {
  42.         error "can only convert version 2.0 Tcl auto-load files"
  43.     }
  44.     set dir [file dirname $tclIndex]  ;# Expected by the script.
  45.     eval [read $tclIndexFH]
  46.     close $tclIndexFH
  47.  
  48.     foreach procName [array names auto_index] {
  49.         if ![string match "source *" $auto_index($procName)] {
  50.             puts stderr "WARNING: Can't convert load command for \"$procName\": $auto_index($procName)"
  51.             set allOK 0
  52.             continue
  53.         }
  54.         set filePath [lindex $auto_index($procName) 1]
  55.         set fileName [file tail $filePath] 
  56.         if {[lsearch $ignore $fileName] >= 0} continue
  57.  
  58.         lappend fileTbl($filePath) $procName
  59.     }
  60.     if ![info exists fileTbl] {
  61.         error "no entries could be converted in $tclIndex"
  62.     }
  63.     return $allOK
  64. }
  65.  
  66.  
  67. proc convert_lib {tclIndex packageLib {ignore {}}} {
  68.     source [info library]/buildidx.tcl
  69.  
  70.     if {[file tail $tclIndex] != "tclIndex"} {
  71.         error "Tail file name must be `tclIndex': $tclIndex"}
  72.     if ![file readable $tclIndex] {
  73.         error "File not readable: $tclIndex"
  74.     }
  75.  
  76.  
  77.     set tclIndex [glob $tclIndex]
  78.     if ![string match "/*" $tclIndex] {
  79.         set tclIndex "[pwd]/$tclIndex"
  80.     }
  81.  
  82.  
  83.     set allOK [tclx:ParseTclIndex $tclIndex fileTbl $ignore]
  84.  
  85.  
  86.     if {[file extension $packageLib] != ".tlib"} {
  87.         append packageLib ".tlib"
  88.     }
  89.     set libFH [open $packageLib w]
  90.  
  91.     foreach srcFile [array names fileTbl] {
  92.         set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]]
  93.         set srcFH [open $srcFile r]
  94.         puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n"
  95.         copyfile $srcFH $libFH
  96.         close $srcFH
  97.     }
  98.     close $libFH
  99.     buildpackageindex $packageLib
  100.     if !$allOK {
  101.         error "*** Not all entries converted, but library generated"
  102.     }
  103. }
  104.  
  105. #@package: TclX-developer_utils saveprocs edprocs
  106.  
  107. proc saveprocs {fileName args} {
  108.     set fp [open $fileName w]
  109.     puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
  110.     puts $fp [eval "showproc $args"]
  111.     close $fp
  112. }
  113.  
  114. proc edprocs {args} {
  115.     global env
  116.  
  117.     set tmpFilename /tmp/tcldev.[id process]
  118.  
  119.     set fp [open $tmpFilename w]
  120.     puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
  121.     puts $fp [eval "showproc $args"]
  122.     close $fp
  123.  
  124.     if [info exists env(EDITOR)] {
  125.         set editor $env(EDITOR)
  126.     } else {
  127.     set editor vi
  128.     }
  129.  
  130.     set startMtime [file mtime $tmpFilename]
  131.     system "$editor $tmpFilename"
  132.  
  133.     if {[file mtime $tmpFilename] != $startMtime} {
  134.     source $tmpFilename
  135.     echo "Procedures were reloaded."
  136.     } else {
  137.     echo "No changes were made."
  138.     }
  139.     unlink $tmpFilename
  140.     return
  141. }
  142.  
  143. #@package: TclX-forfile for_file
  144.  
  145. proc for_file {var filename code} {
  146.     upvar $var line
  147.     set fp [open $filename r]
  148.     while {[gets $fp line] >= 0} {
  149.         uplevel $code
  150.     }
  151.     close $fp
  152. }
  153.  
  154.  
  155. #@package: TclX-globrecur recursive_glob
  156.  
  157. proc recursive_glob {dirlist globlist} {
  158.     set result {}
  159.     set recurse {}
  160.     foreach dir $dirlist {
  161.         if ![file isdirectory $dir] {
  162.             error "\"$dir\" is not a directory"
  163.         }
  164.         foreach pattern $globlist {
  165.             set result [concat $result [glob -nocomplain -- $dir/$pattern]]
  166.         }
  167.         foreach file [glob -nocomplain -- $dir/* $dir/.*] {
  168.             if [file isdirectory $file] {
  169.                 set fileTail [file tail $file]
  170.                 if {!(($fileTail == ".") || ($fileTail == ".."))} {
  171.                     lappend recurse $file
  172.                 }
  173.             }
  174.         }
  175.     }
  176.     if ![lempty $recurse] {
  177.         set result [concat $result [recursive_glob $recurse $globlist]]
  178.     }
  179.     return $result
  180. }
  181.  
  182. #@package: TclX-forrecur for_recursive_glob
  183.  
  184. proc for_recursive_glob {var dirlist globlist code {depth 1}} {
  185.     upvar $depth $var myVar
  186.     set recurse {}
  187.     foreach dir $dirlist {
  188.         if ![file isdirectory $dir] {
  189.             error "\"$dir\" is not a directory"
  190.         }
  191.         foreach pattern $globlist {
  192.             foreach file [glob -nocomplain -- $dir/$pattern] {
  193.                 set myVar $file
  194.                 uplevel $depth $code
  195.             }
  196.         }
  197.         foreach file [glob -nocomplain -- $dir/* $dir/.*] {
  198.             if [file isdirectory $file] {
  199.                 set fileTail [file tail $file]
  200.                 if {!(($fileTail == ".") || ($fileTail == ".."))} {
  201.                     lappend recurse $file
  202.                 }
  203.             }
  204.         }
  205.     }
  206.     if ![lempty $recurse] {
  207.         for_recursive_glob $var $recurse $globlist $code [expr {$depth + 1}]
  208.     }
  209.     return {}
  210. }
  211.  
  212. #@package: TclX-help help helpcd helppwd apropos
  213.  
  214.  
  215. proc help:RootDirs {} {
  216.     global auto_path
  217.     set roots {}
  218.     foreach dir $auto_path {
  219.         if [file isdirectory $dir/help] {
  220.             lappend roots $dir/help
  221.         }
  222.     }
  223.     return $roots
  224. }
  225.  
  226.  
  227. proc help:FlattenPath pathName {
  228.     set newPath {}
  229.     foreach element [split $pathName /] {
  230.         if {"$element" == "." || [lempty $element]} continue
  231.  
  232.         if {"$element" == ".."} {
  233.             if {[llength [join $newPath /]] == 0} {
  234.                 error "Help: name goes above subject directory root"}
  235.             lvarpop newPath [expr [llength $newPath]-1]
  236.             continue
  237.         }
  238.         lappend newPath $element
  239.     }
  240.     set newPath [join $newPath /]
  241.  
  242.  
  243.     if {("$newPath" == "") && [string match "/*" $pathName]} {
  244.         set newPath "/"
  245.     }
  246.         
  247.     return $newPath
  248. }
  249.  
  250.  
  251. proc help:ConvertPath pathName {
  252.     global TCLXENV
  253.  
  254.     if {![string match "/*" $pathName]} {
  255.         if {"$TCLXENV(help:curSubject)" == "/"} {
  256.             set pathName "/$pathName"
  257.         } else {
  258.             set pathName "$TCLXENV(help:curSubject)/$pathName"
  259.         }
  260.     }
  261.     set pathName [help:FlattenPath $pathName]
  262.  
  263.  
  264.     if {$pathName == "/"} {
  265.         return [help:RootDirs]
  266.     }
  267.  
  268.  
  269.     foreach dir [help:RootDirs] {
  270.         if [file readable $dir/$pathName] {
  271.             return [list $dir/$pathName]
  272.         }
  273.     }
  274.     error "\"$pathName\" does not exist"
  275. }
  276.  
  277.  
  278. proc help:RelativePath pathName {
  279.     foreach dir [help:RootDirs] {
  280.         if {[csubstr $pathName 0 [clength $dir]] == $dir} {
  281.             set name [csubstr $pathName [clength $dir] end]
  282.             if {$name == ""} {set name /}
  283.             return $name
  284.         }
  285.     }
  286.     if ![info exists found] {
  287.         error "problem translating \"$pathName\""
  288.     }
  289.  
  290. }
  291.  
  292.  
  293. proc help:ListSubject {pathName pathList subjectsVar pagesVar} {
  294.     upvar $subjectsVar subjects $pagesVar pages
  295.  
  296.     set subjects {}
  297.     set pages {}
  298.     set foundDir 0
  299.     foreach dir $pathList {
  300.         if ![file isdirectory $dir] continue
  301.         set foundDir 1
  302.         foreach file [glob -nocomplain $dir/*] {
  303.             if [string match *.brf $file] continue
  304.             if [file isdirectory $file] {
  305.                 lappend subjects [file tail $file]/
  306.             } else {
  307.                 lappend pages [file tail $file]
  308.             }
  309.         }
  310.     }
  311.     if !$foundDir {
  312.         error "\"$pathName\" is not a subject"
  313.     }
  314.     set subjects [lsort $subjects]
  315.     set pages [lsort $pages]
  316.     return {}
  317. }
  318.  
  319.  
  320. proc help:Display line {
  321.     global TCLXENV
  322.     if {$TCLXENV(help:lineCnt) >= 23} {
  323.         set TCLXENV(help:lineCnt) 0
  324.         puts stdout ":" nonewline
  325.         flush stdout
  326.         gets stdin response
  327.         if {![lempty $response]} {
  328.             return 0}
  329.     }
  330.     puts stdout $line
  331.     incr TCLXENV(help:lineCnt)
  332. }
  333.  
  334.  
  335. proc help:DisplayPage filePath {
  336.  
  337.     set inFH [open $filePath r]
  338.     while {[gets $inFH fileBuf] >= 0} {
  339.         if {![help:Display $fileBuf]} {
  340.             break}
  341.     }
  342.     close $inFH
  343. }    
  344.  
  345.  
  346. proc help:DisplayColumns {nameList} {
  347.     set count 0
  348.     set outLine ""
  349.     foreach name $nameList {
  350.         if {$count == 0} {
  351.             append outLine "   "}
  352.         append outLine $name
  353.         if {[incr count] < 4} {
  354.             set padLen [expr 17-[clength $name]]
  355.             if {$padLen < 3} {
  356.                set padLen 3}
  357.             append outLine [replicate " " $padLen]
  358.         } else {
  359.            if {![help:Display $outLine]} {
  360.                return}
  361.            set outLine ""
  362.            set count 0
  363.         }
  364.     }
  365.     if {$count != 0} {
  366.         help:Display [string trimright $outLine]}
  367.     return
  368. }
  369.  
  370.  
  371. proc help:HelpOnHelp {} {
  372.     set helpPage [lindex [help:ConvertPath /help] 0]
  373.     if [lempty $helpPage] {
  374.         error "No help page on help found"
  375.     }
  376.     help:DisplayPage $helpPage
  377. }
  378.  
  379.  
  380. proc help {{what {}}} {
  381.     global TCLXENV
  382.  
  383.     set TCLXENV(help:lineCnt) 0
  384.  
  385.  
  386.     if {($what == "help") || ($what == "?")} {
  387.         help:HelpOnHelp
  388.         return
  389.     }
  390.  
  391.     set pathList [help:ConvertPath $what]
  392.     if [file isfile [lindex $pathList 0]] {
  393.         help:DisplayPage [lindex $pathList 0]
  394.         return
  395.     }
  396.  
  397.     help:ListSubject $what $pathList subjects pages
  398.     set relativeDir [help:RelativePath [lindex $pathList 0]]
  399.  
  400.     if {[llength $subjects] != 0} {
  401.         help:Display "\nSubjects available in $relativeDir:"
  402.         help:DisplayColumns $subjects
  403.     }
  404.     if {[llength $pages] != 0} {
  405.         help:Display "\nHelp pages available in $relativeDir:"
  406.         help:DisplayColumns $pages
  407.     }
  408. }
  409.  
  410.  
  411.  
  412. proc helpcd {{dir /}} {
  413.     global TCLXENV
  414.  
  415.     set pathName [lindex [help:ConvertPath $dir] 0]
  416.  
  417.     if {![file isdirectory $pathName]} {
  418.         error "Helpcd: \"$dir\" is not a subject"}
  419.  
  420.     set TCLXENV(help:curSubject) [help:RelativePath $pathName]
  421.     return
  422. }
  423.  
  424.  
  425. proc helppwd {} {
  426.         global TCLXENV
  427.         echo "Current help subject: $TCLXENV(help:curSubject)"
  428. }
  429.  
  430.  
  431. proc apropos {regexp} {
  432.     global TCLXENV
  433.  
  434.     set TCLXENV(help:lineCnt) 0
  435.  
  436.     set ch [scancontext create]
  437.     scanmatch -nocase $ch $regexp {
  438.         set path [lindex $matchInfo(line) 0]
  439.         set desc [lrange $matchInfo(line) 1 end]
  440.         if {![help:Display [format "%s - %s" $path $desc]]} {
  441.             set stop 1
  442.             return}
  443.     }
  444.     set stop 0
  445.     foreach dir [help:RootDirs] {
  446.         foreach brief [glob -nocomplain $dir/*.brf] {
  447.             set briefFH [open $brief]
  448.             scanfile $ch $briefFH
  449.             close $briefFH
  450.             if $stop break
  451.         }
  452.         if $stop break
  453.     }
  454.     scancontext delete $ch
  455. }
  456.  
  457. global TCLXENV
  458.  
  459. set TCLXENV(help:curSubject) "/"
  460.  
  461. #@package: TclX-profrep profrep
  462.  
  463. proc profrep:summarize {profDataVar stackDepth sumProfDataVar} {
  464.     upvar $profDataVar profData $sumProfDataVar sumProfData
  465.  
  466.     if {(![info exists profData]) || ([catch {array size profData}] != 0)} {
  467.         error "`profDataVar' must be the name of an array returned by the `profile off' command"
  468.     }
  469.     set maxNameLen 0
  470.     foreach procStack [array names profData] {
  471.         foreach procName $procStack {
  472.             set maxNameLen [max $maxNameLen [clength $procName]]
  473.         }
  474.         if {[llength $procStack] < $stackDepth} {
  475.             set sigProcStack $procStack
  476.         } else {
  477.             set sigProcStack [lrange $procStack 0 [expr {$stackDepth - 1}]]
  478.         }
  479.         if [info exists sumProfData($sigProcStack)] {
  480.             set cur $sumProfData($sigProcStack)
  481.             set add $profData($procStack)
  482.             set     new [expr [lindex $cur 0]+[lindex $add 0]]
  483.             lappend new [expr [lindex $cur 1]+[lindex $add 1]]
  484.             lappend new [expr [lindex $cur 2]+[lindex $add 2]]
  485.             set sumProfData($sigProcStack) $new
  486.         } else {
  487.             set sumProfData($sigProcStack) $profData($procStack)
  488.         }
  489.     }
  490.     return $maxNameLen
  491. }
  492.  
  493. proc profrep:sort {sumProfDataVar sortKey} {
  494.     upvar $sumProfDataVar sumProfData
  495.  
  496.     case $sortKey {
  497.         {calls} {set keyIndex 0}
  498.         {real}  {set keyIndex 1}
  499.         {cpu}   {set keyIndex 2}
  500.         default {
  501.             error "Expected a sort type of: `calls', `cpu' or ` real'"}
  502.     }
  503.  
  504.  
  505.     foreach procStack [array names sumProfData] {
  506.         set key [format "%016d" [lindex $sumProfData($procStack) $keyIndex]]
  507.         lappend keyProcList [list $key $procStack]
  508.     }
  509.     set keyProcList [lsort $keyProcList]
  510.  
  511.  
  512.     for {set idx [expr [llength $keyProcList]-1]} {$idx >= 0} {incr idx -1} {
  513.         lappend sortedProcList [lindex [lindex $keyProcList $idx] 1]
  514.     }
  515.     return $sortedProcList
  516. }
  517.  
  518.  
  519. proc profrep:print {sumProfDataVar sortedProcList maxNameLen outFile
  520.                     userTitle} {
  521.     upvar $sumProfDataVar sumProfData
  522.     
  523.     if {$outFile == ""} {
  524.         set outFH stdout
  525.     } else {
  526.         set outFH [open $outFile w]
  527.     }
  528.  
  529.  
  530.     set stackTitle "Procedure Call Stack"
  531.     set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]]
  532.     set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
  533.                     "Calls" "Real Time" "CPU Time"]
  534.     if {$userTitle != ""} {
  535.         puts $outFH [replicate - [clength $hdr]]
  536.         puts $outFH $userTitle
  537.     }
  538.     puts $outFH [replicate - [clength $hdr]]
  539.     puts $outFH $hdr
  540.     puts $outFH [replicate - [clength $hdr]]
  541.  
  542.  
  543.     foreach procStack $sortedProcList {
  544.         set data $sumProfData($procStack)
  545.         puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \
  546.                             [lvarpop procStack] \
  547.                             [lindex $data 0] [lindex $data 1] [lindex $data 2]]
  548.         foreach procName $procStack {
  549.             if {$procName == "<global>"} break
  550.             puts $outFH "    $procName"
  551.         }
  552.     }
  553.     if {$outFile != ""} {
  554.         close $outFH
  555.     }
  556. }
  557.  
  558.  
  559. proc profrep {profDataVar sortKey stackDepth {outFile {}} {userTitle {}}} {
  560.     upvar $profDataVar profData
  561.  
  562.     set maxNameLen [profrep:summarize profData $stackDepth sumProfData]
  563.     set sortedProcList [profrep:sort sumProfData $sortKey]
  564.     profrep:print sumProfData $sortedProcList $maxNameLen $outFile $userTitle
  565.  
  566. }
  567.  
  568. #@package: TclX-directory_stack pushd popd dirs
  569.  
  570. global TCLXENV(dirPushList)
  571.  
  572. set TCLXENV(dirPushList) ""
  573.  
  574. proc pushd {args} {
  575.     global TCLXENV
  576.  
  577.     if {[llength $args] > 1} {
  578.         error "bad # args: pushd [dir_to_cd_to]"
  579.     }
  580.     set TCLXENV(dirPushList) [linsert $TCLXENV(dirPushList) 0 [pwd]]
  581.  
  582.     if {[llength $args] != 0} {
  583.         cd [glob $args]
  584.     }
  585. }
  586.  
  587. proc popd {} {
  588.     global TCLXENV
  589.  
  590.     if [llength $TCLXENV(dirPushList)] {
  591.         cd [lvarpop TCLXENV(dirPushList)]
  592.         pwd
  593.     } else {
  594.         error "directory stack empty"
  595.     }
  596. }
  597.  
  598. proc dirs {} { 
  599.     global TCLXENV
  600.     echo [pwd] $TCLXENV(dirPushList)
  601. }
  602.  
  603. #@package: TclX-set_functions union intersect intersect3 lrmdups
  604.  
  605. proc union {lista listb} {
  606.     set full_list [lsort [concat $lista $listb]]
  607.     set check_element [lindex $full_list 0]
  608.     set outlist $check_element
  609.     foreach element [lrange $full_list 1 end] {
  610.     if {$check_element == $element} continue
  611.     lappend outlist $element
  612.     set check_element $element
  613.     }
  614.     return $outlist
  615. }
  616.  
  617. proc lrmdups list {
  618.     if [lempty $list] {
  619.         return {}
  620.     }
  621.     set list [lsort $list]
  622.     set last [lvarpop list]
  623.     lappend result $last
  624.     foreach element $list {
  625.     if {$last != $element} {
  626.         lappend result $element
  627.         set last $element
  628.     }
  629.     }
  630.     return $result
  631. }
  632.  
  633.  
  634. proc intersect3 {list1 list2} {
  635.     set list1Result ""
  636.     set list2Result ""
  637.     set intersectList ""
  638.  
  639.     set list1 [lrmdups $list1]
  640.     set list2 [lrmdups $list2]
  641.  
  642.     while {1} {
  643.         if [lempty $list1] {
  644.             if ![lempty $list2] {
  645.                 set list2Result [concat $list2Result $list2]
  646.             }
  647.             break
  648.         }
  649.         if [lempty $list2] {
  650.         set list1Result [concat $list1Result $list1]
  651.             break
  652.         }
  653.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  654.  
  655.         if {$compareResult < 0} {
  656.             lappend list1Result [lvarpop list1]
  657.             continue
  658.         }
  659.         if {$compareResult > 0} {
  660.             lappend list2Result [lvarpop list2]
  661.             continue
  662.         }
  663.         lappend intersectList [lvarpop list1]
  664.         lvarpop list2
  665.     }
  666.     return [list $list1Result $intersectList $list2Result]
  667. }
  668.  
  669. proc intersect {list1 list2} {
  670.     set intersectList ""
  671.  
  672.     set list1 [lsort $list1]
  673.     set list2 [lsort $list2]
  674.  
  675.     while {1} {
  676.         if {[lempty $list1] || [lempty $list2]} break
  677.  
  678.         set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
  679.  
  680.         if {$compareResult < 0} {
  681.             lvarpop list1
  682.             continue
  683.         }
  684.  
  685.         if {$compareResult > 0} {
  686.             lvarpop list2
  687.             continue
  688.         }
  689.  
  690.         lappend intersectList [lvarpop list1]
  691.         lvarpop list2
  692.     }
  693.     return $intersectList
  694. }
  695.  
  696.  
  697.  
  698. #@package: TclX-showproc showproc
  699.  
  700. proc showproc args {
  701.     if [lempty $args] {
  702.         set args [info procs]
  703.     }
  704.     set out {}
  705.  
  706.     foreach procname $args {
  707.         if [lempty [info procs $procname]] {
  708.             auto_load $procname
  709.         }
  710.         set arglist [info args $procname]
  711.         set nargs {}
  712.         while {[llength $arglist] > 0} {
  713.             set varg [lvarpop arglist 0]
  714.             if [info default $procname $varg defarg] {
  715.                 lappend nargs [list $varg $defarg]
  716.             } else {
  717.                 lappend nargs $varg
  718.             }
  719.         }
  720.         append out "proc $procname [list $nargs] \{[info body $procname]\}\n"
  721.     }
  722.     return $out
  723. }
  724.  
  725. #@package: TclX-stringfile_functions read_file write_file
  726.  
  727. proc read_file {fileName args} {
  728.     if {$fileName == "-nonewline"} {
  729.         set flag $fileName
  730.         set fileName [lvarpop args]
  731.     } else {
  732.         set flag {}
  733.     }
  734.     set fp [open $fileName]
  735.     set stat [catch {
  736.         eval read $flag $fp $args
  737.     } result]
  738.     close $fp
  739.     if {$stat != 0} {
  740.         global errorInfo errorCode
  741.         error $result $errorInfo $errorCode
  742.     }
  743.     return $result
  744. } 
  745.  
  746. proc write_file {fileName args} {
  747.     set fp [open $fileName w]
  748.     
  749.     set stat [catch {
  750.         foreach string $args {
  751.             puts $fp $string
  752.         }
  753.     } result]
  754.     close $fp
  755.     if {$stat != 0} {
  756.         global errorInfo errorCode
  757.         error $result $errorInfo $errorCode
  758.     }
  759. }
  760.  
  761.  
  762. #@package: TclX-libraries searchpath auto_load_file
  763.  
  764. proc searchpath {pathlist file} {
  765.     foreach dir $pathlist {
  766.         if {$dir == ""} {set dir .}
  767.         if {[catch {file exists $dir/$file} result] == 0 && $result}  {
  768.             return $dir/$file
  769.         }
  770.     }
  771.     return {}
  772. }
  773.  
  774. proc auto_load_file {name} {
  775.     global auto_path errorCode
  776.     if {[string first / $name] >= 0} {
  777.         return  [uplevel 1 source $name]
  778.     }
  779.     set where [searchpath $auto_path $name]
  780.     if [lempty $where] {
  781.         error "couldn't find $name in any directory in auto_path"
  782.     }
  783.     uplevel 1 source $where
  784. }
  785.  
  786. #@package: TclX-lib-list auto_packages auto_commands
  787.  
  788.  
  789. proc auto_packages {{option {}}} {
  790.     global auto_pkg_index
  791.  
  792.     auto_load  ;# Make sure all indexes are loaded.
  793.     if ![info exists auto_pkg_index] {
  794.         return {}
  795.     }
  796.     
  797.     set packList [array names auto_pkg_index] 
  798.     if [lempty $option] {
  799.         return $packList
  800.     }
  801.  
  802.     if {$option != "-files"} {
  803.         error "Unknow option \"$option\", expected \"-files\""
  804.     }
  805.     set locList {}
  806.     foreach pack $packList {
  807.         lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
  808.     }
  809.     return $locList
  810. }
  811.  
  812.  
  813. proc auto_commands {{option {}}} {
  814.     global auto_index
  815.  
  816.     auto_load  ;# Make sure all indexes are loaded.
  817.     if ![info exists auto_index] {
  818.         return {}
  819.     }
  820.     
  821.     set cmdList [array names auto_index] 
  822.     if [lempty $option] {
  823.         return $cmdList
  824.     }
  825.  
  826.     if {$option != "-loaders"} {
  827.         error "Unknow option \"$option\", expected \"-loaders\""
  828.     }
  829.     set loadList {}
  830.     foreach cmd $cmdList {
  831.         lappend loadList [list $cmd $auto_index($cmd)]
  832.     }
  833.     return $loadList
  834. }
  835.  
  836. #@package: TclX-ucblib auto_reset auto_mkindex
  837.  
  838.  
  839. proc auto_reset {} {
  840.     global auto_execs auto_index auto_oldpath
  841.     foreach p [info procs] {
  842.     if {[info exists auto_index($p)] && ($p != "unknown")
  843.         && ![string match auto_* $p]} {
  844.         rename $p {}
  845.     }
  846.     }
  847.     catch {unset auto_execs}
  848.     catch {unset auto_index}
  849.     catch {unset auto_oldpath}
  850.     catch {unset auto_pkg_index}
  851.     set auto_index(buildpackageindex) {source [info library]/buildidx.tcl}
  852.     return
  853. }
  854.  
  855.  
  856. proc auto_mkindex {dir files} {
  857.     global errorCode errorInfo
  858.     set oldDir [pwd]
  859.     cd $dir
  860.     set dir [pwd]
  861.     append index "# Tcl autoload index file, version 2.0\n"
  862.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  863.     append index "# and sourced to set up indexing information for one or\n"
  864.     append index "# more commands.  Typically each line is a command that\n"
  865.     append index "# sets an element in the auto_index array, where the\n"
  866.     append index "# element name is the name of a command and the value is\n"
  867.     append index "# a script that loads the command.\n\n"
  868.     foreach file [glob $files] {
  869.     set f ""
  870.     set error [catch {
  871.         set f [open $file]
  872.         while {[gets $f line] >= 0} {
  873.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  874.             append index "set [list auto_index($procName)]"
  875.             append index " \"source \$dir/$file\"\n"
  876.         }
  877.         }
  878.         close $f
  879.     } msg]
  880.     if $error {
  881.         set code $errorCode
  882.         set info $errorInfo
  883.         catch [close $f]
  884.         cd $oldDir
  885.         error $msg $info $code
  886.     }
  887.     }
  888.     set f [open tclIndex w]
  889.     puts $f $index nonewline
  890.     close $f
  891.     cd $oldDir
  892. }
  893.  
  894.  
  895. #@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \
  896.            sin sinh sqrt tan tanh fmod pow atan2 abs double int round
  897.  
  898. proc acos  x {uplevel [list expr acos($x)]}
  899. proc asin  x {uplevel [list expr asin($x)]}
  900. proc atan  x {uplevel [list expr atan($x)]}
  901. proc ceil  x {uplevel [list expr ceil($x)]}
  902. proc cos   x {uplevel [list expr cos($x)]}
  903. proc cosh  x {uplevel [list expr cosh($x)]}
  904. proc exp   x {uplevel [list expr exp($x)]}
  905. proc fabs  x {uplevel [list expr abs($x)]}
  906. proc floor x {uplevel [list expr floor($x)]}
  907. proc log   x {uplevel [list expr log($x)]}
  908. proc log10 x {uplevel [list expr log10($x)]}
  909. proc sin   x {uplevel [list expr sin($x)]}
  910. proc sinh  x {uplevel [list expr sinh($x)]}
  911. proc sqrt  x {uplevel [list expr sqrt($x)]}
  912. proc tan   x {uplevel [list expr tan($x)]}
  913. proc tanh  x {uplevel [list expr tanh($x)]}
  914.  
  915. proc fmod {x n} {uplevel [list expr fmod($x,$n)]}
  916. proc pow {x n} {uplevel [list expr pow($x,$n)]}
  917.  
  918.  
  919. proc atan2  x {uplevel [list expr atan2($x)]}
  920. proc abs    x {uplevel [list expr abs($x)]}
  921. proc double x {uplevel [list expr double($x)]}
  922. proc int    x {uplevel [list expr int($x)]}
  923. proc round  x {uplevel [list expr round($x)]}
  924.  
  925.  
  926. #@package: TclX-shell tclx_unknown2 auto_execok
  927.  
  928.  
  929. proc tclx_unknown2 cmd {
  930.     global tcl_interactive auto_noexec
  931.  
  932.     set name [lindex $cmd 0]
  933.  
  934.     if ![info exists auto_noexec] {
  935.         if [auto_execok $name] {
  936.             if {!$tcl_interactive || ([info level] > 2) ||
  937.                 [info script] != ""} {
  938.                 error "Auto execution of Unix commands only supported as interactive commands.\nUse \"exec\" to execute \"$name\""
  939.             }
  940.             uplevel 2 system [list $cmd]
  941.             return
  942.         }
  943.     }
  944.  
  945.     if {!$tcl_interactive || ([info level] > 2) || [info script] != ""} {
  946.         error "invalid command name \"$name\""
  947.     }
  948.  
  949.  
  950.     if {([info level] == 2) && ([info script] == "")} {
  951.         if {$name == "!!"} {
  952.             return [uplevel 2 {history redo}]
  953.         }
  954.         if [regexp {^!(.+)$} $name dummy event] {
  955.             return [uplevel 2 [list history redo $event]]
  956.         }
  957.         if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  958.             return [uplevel 2 [list history substitute $old $new]]
  959.         }
  960.         set cmds [info commands $name*]
  961.         if {[llength $cmds] == 1} {
  962.             return [uplevel 2 [lreplace $cmd 0 0 $cmds]]
  963.         }
  964.         if {[llength $cmds] != 0} {
  965.             if {$name == ""} {
  966.                 return -code error "empty command name \"\""
  967.             } else {
  968.                 return -code error \
  969.                         "ambiguous command name \"$name\": [lsort $cmds]"
  970.             }
  971.         }
  972.     }
  973.     error "invalid command name \"$name\""
  974. }
  975.  
  976.  
  977.  
  978. proc auto_execok name {
  979.     global auto_execs env
  980.  
  981.     if [info exists auto_execs($name)] {
  982.         return $auto_execs($name)
  983.     }
  984.     set auto_execs($name) 0
  985.     if {[string first / $name] >= 0} {
  986.     if {[file executable $name] && ![file isdirectory $name]} {
  987.         puts "special, ok!"
  988.         set auto_execs($name) 1
  989.     }
  990.     return $auto_execs($name)
  991.     }
  992.     foreach dir [split $env(PATH) :] {
  993.         if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  994.             set auto_execs($name) 1
  995.             return 1
  996.         }
  997.     }
  998.     return 0
  999. }
  1000.  
  1001. #@package: TclX-buildhelp buildhelp
  1002.  
  1003. proc TruncFileName {pathName} {
  1004.     global truncFileNames
  1005.  
  1006.     if {!$truncFileNames} {
  1007.         return $pathName}
  1008.     set fileName [file tail $pathName]
  1009.     if {"[crange $fileName 0 3]" == "Tcl_"} {
  1010.         set fileName [crange $fileName 4 end]}
  1011.     set fileName [crange $fileName 0 13]
  1012.     return "[file dirname $pathName]/$fileName"
  1013. }
  1014.  
  1015.  
  1016. proc EnsureDirs {filePath} {
  1017.     set dirPath [file dirname $filePath]
  1018.     if [file exists $dirPath] return
  1019.     foreach dir [split $dirPath /] {
  1020.         lappend dirList $dir
  1021.         set partPath [join $dirList /]
  1022.         if [file exists $partPath] continue
  1023.  
  1024.         mkdir $partPath
  1025.         chmod u=rwx,go=rx $partPath
  1026.     }
  1027. }
  1028.  
  1029.  
  1030. proc CreateFilterNroffManPageContext {} {
  1031.     global filterNroffManPageContext
  1032.  
  1033.     set filterNroffManPageContext [scancontext create]
  1034.  
  1035.  
  1036.     scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
  1037.         catch {unset prev2Blanks}
  1038.         catch {unset prev1Line}
  1039.         catch {unset prev1Blanks}
  1040.         set nukeBlanks {}
  1041.     }
  1042.  
  1043.  
  1044.     scanmatch $filterNroffManPageContext {$^} {
  1045.         if ![info exists nukeBlanks] {
  1046.             append prev1Blanks \n
  1047.         }
  1048.     }
  1049.  
  1050.  
  1051.     scanmatch $filterNroffManPageContext {
  1052.         catch {unset nukeBlanks}
  1053.         if [info exists prev2Line] {
  1054.             puts $outFH $prev2Line
  1055.             unset prev2Line
  1056.         }
  1057.         if [info exists prev2Blanks] {
  1058.             puts $outFH $prev2Blanks nonewline
  1059.             unset prev2Blanks
  1060.         }
  1061.         if [info exists prev1Line] {
  1062.             set prev2Line $prev1Line
  1063.         }
  1064.         set prev1Line $matchInfo(line)
  1065.         if [info exists prev1Blanks] {
  1066.             set prev2Blanks $prev1Blanks
  1067.             unset prev1Blanks
  1068.         }
  1069.     }
  1070. }
  1071.  
  1072.  
  1073. proc FilterNroffManPage {inFH outFH} {
  1074.     global filterNroffManPageContext
  1075.  
  1076.     if ![info exists filterNroffManPageContext] {
  1077.         CreateFilterNroffManPageContext
  1078.     }
  1079.  
  1080.     scanfile $filterNroffManPageContext $inFH
  1081.  
  1082.     if [info exists prev2Line] {
  1083.         puts $outFH $prev2Line
  1084.     }
  1085. }
  1086.  
  1087.  
  1088. proc CreateExtractNroffHeaderContext {} {
  1089.     global extractNroffHeaderContext
  1090.  
  1091.     set extractNroffHeaderContext [scancontext create]
  1092.  
  1093.     scanmatch $extractNroffHeaderContext {'\\"@endheader[     ]*$} {
  1094.         break
  1095.     }
  1096.     scanmatch $extractNroffHeaderContext {'\\"@:} {
  1097.         append nroffHeader "[crange $matchInfo(line) 5 end]\n"
  1098.     }
  1099.     scanmatch $extractNroffHeaderContext {
  1100.         append nroffHeader "$matchInfo(line)\n"
  1101.     }
  1102. }
  1103.  
  1104.  
  1105. proc ExtractNroffHeader {manPageFH} {
  1106.     global extractNroffHeaderContext nroffHeader
  1107.  
  1108.     if ![info exists extractNroffHeaderContext] {
  1109.         CreateExtractNroffHeaderContext
  1110.     }
  1111.     scanfile $extractNroffHeaderContext $manPageFH
  1112. }
  1113.  
  1114.  
  1115.  
  1116. proc CreateExtractNroffHelpContext {} {
  1117.     global extractNroffHelpContext
  1118.  
  1119.     set extractNroffHelpContext [scancontext create]
  1120.  
  1121.     scanmatch $extractNroffHelpContext {^'\\"@endhelp[     ]*$} {
  1122.         break
  1123.     }
  1124.  
  1125.     scanmatch $extractNroffHelpContext {^'\\"@brief:} {
  1126.         if $foundBrief {
  1127.             error {Duplicate "@brief:" entry}
  1128.         }
  1129.         set foundBrief 1
  1130.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
  1131.         continue
  1132.     }
  1133.  
  1134.     scanmatch $extractNroffHelpContext {^'\\"@:} {
  1135.         puts $nroffFH  [csubstr $matchInfo(line) 5 end]
  1136.         continue
  1137.     }
  1138.     scanmatch $extractNroffHelpContext {^'\\"@help:} {
  1139.         error {"@help" found within another help section"}
  1140.     }
  1141.     scanmatch $extractNroffHelpContext {
  1142.         puts $nroffFH $matchInfo(line)
  1143.     }
  1144. }
  1145.  
  1146.  
  1147. proc ExtractNroffHelp {manPageFH manLine} {
  1148.     global helpDir nroffHeader briefHelpFH colArgs
  1149.     global extractNroffHelpContext
  1150.  
  1151.     if ![info exists extractNroffHelpContext] {
  1152.         CreateExtractNroffHelpContext
  1153.     }
  1154.  
  1155.     set helpName [string trim [csubstr $manLine 9 end]]
  1156.     set helpFile [TruncFileName "$helpDir/$helpName"]
  1157.     if [file exists $helpFile] {
  1158.         error "Help file already exists: $helpFile"
  1159.     }
  1160.     EnsureDirs $helpFile
  1161.  
  1162.     set tmpFile "[file dirname $helpFile]/tmp.[id process]"
  1163.  
  1164.     echo "    creating help file $helpName"
  1165.  
  1166.     set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]
  1167.  
  1168.     puts $nroffFH {.TH @@@BUILDHELP@@@ 1}
  1169.  
  1170.     set foundBrief 0
  1171.     scanfile $extractNroffHelpContext $manPageFH
  1172.  
  1173.  
  1174.     set stat [catch {
  1175.         close $nroffFH
  1176.     } msg]
  1177.     if $stat {
  1178.         puts stderr "nroff: $msg"
  1179.     }
  1180.  
  1181.     set tmpFH [open $tmpFile r]
  1182.     set helpFH [open $helpFile w]
  1183.  
  1184.     FilterNroffManPage $tmpFH $helpFH
  1185.  
  1186.     close $tmpFH
  1187.     close $helpFH
  1188.  
  1189.     unlink $tmpFile
  1190.     chmod a-w,a+r $helpFile
  1191. }
  1192.  
  1193.  
  1194. proc CreateExtractScriptHelpContext {} {
  1195.     global extractScriptHelpContext
  1196.  
  1197.     set extractScriptHelpContext [scancontext create]
  1198.  
  1199.     scanmatch $extractScriptHelpContext {^#@endhelp[     ]*$} {
  1200.         break
  1201.     }
  1202.  
  1203.     scanmatch $extractScriptHelpContext {^#@brief:} {
  1204.         if $foundBrief {
  1205.             error {Duplicate "@brief" entry}
  1206.         }
  1207.         set foundBrief 1
  1208.         puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
  1209.         continue
  1210.     }
  1211.  
  1212.     scanmatch $extractScriptHelpContext {^#@help:} {
  1213.         error {"@help" found within another help section"}
  1214.     }
  1215.     scanmatch $extractScriptHelpContext {
  1216.         if {[clength $matchInfo(line)] > 1} {
  1217.             puts $helpFH " [csubstr $matchInfo(line) 1 end]"
  1218.         } else {
  1219.             puts $helpFH $matchInfo(line)
  1220.         }
  1221.     }
  1222. }
  1223.  
  1224.  
  1225. proc ExtractScriptHelp {ScriptPageFH ScriptLine} {
  1226.     global helpDir briefHelpFH
  1227.     global extractScriptHelpContext
  1228.  
  1229.     if ![info exists extractScriptHelpContext] {
  1230.         CreateExtractScriptHelpContext
  1231.     }
  1232.  
  1233.     set helpName [string trim [csubstr $ScriptLine 7 end]]
  1234.     set helpFile "$helpDir/$helpName"
  1235.     if {[file exists $helpFile]} {
  1236.         error "Help file already exists: $helpFile"
  1237.     }
  1238.     EnsureDirs $helpFile
  1239.  
  1240.     echo "    creating help file $helpName"
  1241.  
  1242.     set helpFH [open $helpFile w]
  1243.  
  1244.     set foundBrief 0
  1245.     scanfile $extractScriptHelpContext $manPageFH
  1246.  
  1247.     close $helpFH
  1248.     chmod a-w,a+r $helpFile
  1249. }
  1250.  
  1251.  
  1252. proc ProcessNroffFile {pathName} {
  1253.    global nroffScanCT scriptScanCT nroffHeader
  1254.  
  1255.    set fileName [file tail $pathName]
  1256.  
  1257.    set nroffHeader {}
  1258.    set manPageFH [open $pathName r]
  1259.    set matchInfo(fileName) [file tail $pathName]
  1260.  
  1261.    echo "    scanning $pathName"
  1262.  
  1263.    scanfile $nroffScanCT $manPageFH
  1264.  
  1265.    close $manPageFH
  1266. }
  1267.  
  1268.  
  1269. proc ProcessTclScript {pathName} {
  1270.    global scriptScanCT nroffHeader
  1271.  
  1272.    set scriptFH [open "$pathName" r]
  1273.    set matchInfo(fileName) [file tail $pathName]
  1274.  
  1275.    echo "    scanning $pathName"
  1276.    scanfile $scriptScanCT $scriptFH
  1277.  
  1278.    close $scriptFH
  1279. }
  1280.  
  1281.  
  1282. proc buildhelp {helpDirPath briefFile sourceFiles} {
  1283.     global helpDir truncFileNames nroffScanCT
  1284.     global scriptScanCT briefHelpFH colArgs
  1285.  
  1286.     echo ""
  1287.     echo "Begin building help tree"
  1288.  
  1289.     if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
  1290.         set colArgs {-b}
  1291.     } else {
  1292.         set colArgs {-bx}
  1293.     }
  1294.     set helpDir $helpDirPath
  1295.     if {![file exists $helpDir]} {
  1296.         mkdir $helpDir
  1297.     }
  1298.  
  1299.     if {![file isdirectory $helpDir]} {
  1300.         error [concat "$helpDir is not a directory or does not exist. "  
  1301.                       "This should be the help root directory"]
  1302.     }
  1303.         
  1304.     set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
  1305.     if {$status != 0} {
  1306.         set truncFileNames 1
  1307.     } else {
  1308.         close $tmpFH
  1309.         unlink $helpDir/AVeryVeryBigFileName
  1310.         set truncFileNames 0
  1311.     }
  1312.  
  1313.     set nroffScanCT [scancontext create]
  1314.  
  1315.     scanmatch $nroffScanCT {'\\"@help:} {
  1316.         ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
  1317.         continue
  1318.     }
  1319.  
  1320.     scanmatch $nroffScanCT {^'\\"@header} {
  1321.         ExtractNroffHeader $matchInfo(handle)
  1322.         continue
  1323.     }
  1324.     scanmatch $nroffScanCT {^'\\"@endhelp} {
  1325.         error [concat {@endhelp" without corresponding "@help:"} \
  1326.                  ", offset = $matchInfo(offset)"]
  1327.     }
  1328.     scanmatch $nroffScanCT {^'\\"@brief} {
  1329.         error [concat {"@brief" without corresponding "@help:"} \
  1330.                  ", offset = $matchInfo(offset)"]
  1331.     }
  1332.  
  1333.     set scriptScanCT [scancontext create]
  1334.     scanmatch $scriptScanCT {^#@help:} {
  1335.         ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
  1336.     }
  1337.  
  1338.     if {[file extension $briefFile] != ".brf"} {
  1339.         error "Brief file \"$briefFile\" must have an extension \".brf\""
  1340.     }
  1341.     if [file exists $helpDir/$briefFile] {
  1342.         error "Brief file \"$helpDir/$briefFile\" already exists"
  1343.     }
  1344.     set briefHelpFH [open "|sort > $helpDir/$briefFile" w]
  1345.  
  1346.     foreach manFile [glob $sourceFiles] {
  1347.         set ext [file extension $manFile]
  1348.         if {$ext == ".tcl" || $ext == ".tlib"} {
  1349.             set status [catch {ProcessTclScript $manFile} msg]
  1350.         } else {
  1351.             set status [catch {ProcessNroffFile $manFile} msg]
  1352.         }
  1353.         if {$status != 0} {
  1354.             global errorInfo errorCode
  1355.             error "Error extracting help from: $manFile" $errorInfo $errorCode
  1356.         }
  1357.     }
  1358.  
  1359.     close $briefHelpFH
  1360.     chmod a-w,a+r $helpDir/$briefFile
  1361.     echo "Completed extraction of help files"
  1362. }
  1363.  
  1364.  
  1365. #@package: Tcl-parray parray
  1366.  
  1367.  
  1368. proc parray a {
  1369.     upvar 1 $a array
  1370.     if [catch {array size array}] {
  1371.     error "\"$a\" isn't an array"
  1372.     }
  1373.     set maxl 0
  1374.     foreach name [lsort [array names array]] {
  1375.     if {[string length $name] > $maxl} {
  1376.         set maxl [string length $name]
  1377.     }
  1378.     }
  1379.     set maxl [expr {$maxl + [string length $a] + 2}]
  1380.     foreach name [lsort [array names array]] {
  1381.     set nameString [format %s(%s) $a $name]
  1382.     puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
  1383.     }
  1384. }
  1385.